(DECLARE (SPECIAL PRETTYPROPS PRETTYFLG COMMENTCOL COMMENTFLG %%LL %%BR %%CC %%T
		  %%LP %%RP)
	 (NOCALL %SPRINT)
	 (DM * (%L) NIL))
 
(PUTPROP @* (GET @NILL @FSUBR) @FSUBR)
 
(DEFPROP %CURRCOL
 (LAMBDA (L)
  				       (* Returns the column where the next
					  printed character will appear; Made
					  into a macro because it is called so
					  frequently)
  @(ADD1 (*DIF %%LL (CHRCT))))
MACRO)
 
(DEFPROP PPL
 (LAMBDA (%L)
  				       (* Replaces GRINL)
  (MAPC (FUNCTION (LAMBDA (%A)
		   (OR [MEMB %A (SETQ %L (EVAL %A))] [NCONC %L (LIST %A)])
		   (APPLY# @PP %L)))
	%L))
FEXPR)
 
(DEFPROP PPL*
 (LAMBDA (%L)
  (PROG (COMMENTFLG)
	(SETQ COMMENTFLG T)
	(APPLY# @PPL %L)))
FEXPR)
 
(DEFPROP PP
 (LAMBDA (%L)
  				       (* Replaces GRINDEF; Outputs page eject
					  if *PAGE* encountered; Notifies user
					  of any atoms with no props on
					  PRETTYPROPS if dumping to a file)
  (PROG (%F %FLAG %D)
	(SETQ %F (OUTCH))
	(MAPC
	 (FUNCTION
	  (LAMBDA (%A)
	   (COND
	    [(CONSP %A)
	     (TERPRI)
	     (TERPRI)
	     (COND [(AND [CONSP (CAR %A)] [EQ (CAAR %A) @LAP])
		    (PRIN1 (CAR %A))
		    (MAPC (FUNCTION (LAMBDA (X)
				     (TAB (COND [(AND X [ATOM X]) 2Q] [T 11Q]))
				     (SETQ %A (PRIN1 X))))
			  (CDR %A))
		    (COND [%A (TAB 11Q) (PRIN1 NIL)])]
		   [T (SPRINT %A 1Q)])]
	    [(EQ %A @*PAGE*) (TYO 14Q)]
	    [T (SETQ %FLAG NIL)
	       (MAPC
		(FUNCTION
		 (LAMBDA (%P)
		  (PROG (%SP)
			(COND [(CONSP %P)
			       (SETQ %SP (CDR %P))
			       (SETQ %P (CAR %P))])
			(COND
			 [(AND
			   [SETQ %D (GET %A %P)]
			   [OR [PATOM %D]
			       [COND [(AND [MEMB %P @(EXPR FEXPR MACRO)]
					   [SETQ %L (GET %A @TRACE)])
				      (AND [SETQ %L
						 (GETL (CDR %L)
						       @(EXPR FEXPR MACRO))]
					   [SETQ %D (CADR %L)])]
				     [(NEQ (CDR %D) (UNBOUND))]]])
			  (SETQ %FLAG T)
			  (TERPRI)
			  (TERPRI)
			  (COND [%SP (%SP %A %D %P)]
				[(OR [ATOM %D]
				     [AND [ATOM (CAR %D)] [ATOM (CDR %D)]])
				 (SPRINT (LIST @DEFPROP %A %D %P) 1Q)]
				[T (PRINC @/(DEFPROP/ )
				   (PRIN1 %A)
				   (SPRINT %D 2Q)
				   (TERPRI)
				   (PRIN1 %P)
				   (PRINC @/))])]))))
		PRETTYPROPS)
	       (COND [(AND %F [NULL %FLAG])
		      (OUTC NIL NIL)
		      (AND [LESSP (CHRCT) 17Q] [TERPRI])
		      (PRINC @/ )
		      (PRIN1 %A)
		      (OUTC %F NIL)])])))
	 %L)
	(TERPRI)))
FEXPR)
 
(DEFPROP PP*
 (LAMBDA (%L)
  (PROG (COMMENTFLG)
	(SETQ COMMENTFLG T)
	(APPLY# @PP %L)))
FEXPR)
 
(DEFPROP PP-RMACS
 (LAMBDA (%A %D %P)
  (SETQ %P (SETCHR %A NIL))
  (SPRINT (LIST (COND [(EQ %P 13Q) @DSM] [T @DRM]) %A %D) 1Q))
EXPR)
 
(DEFPROP SPRINT
 (LAMBDA (%E %C)
  				       (* SPRINT now does a quick dump if
					  PRETTYFLG=NIL)
  (SETQ %%LL (LINELENGTH NIL))
  (TAB %C)
  (COND [(OR [NULL PRETTYFLG] [ATOM %E]) (PRIN1 %E)] [T (%SPRINT %E NIL)]))
EXPR)
 
(DEFPROP %SPRINT
 (LAMBDA (%E %BR)
  				       (* Prettyprints the <non-atomic>
					  structure %E using parentheses if
					  %BR=NIL and brackets if %BR=T; Checks
					  for printmacros and lists of atoms
					  <printed as blocks>)
  (PROG (%C %CE)
	(COND [%BR (SETQ %%LP @/[) (SETQ %BR (SETQ %%RP @/]))]
	      [T (SETQ %%LP @/() (SETQ %BR (SETQ %%RP @/)))])
  START	(SETQ %C (ADD1 (%CURRCOL)))
	(COND [(CONSP (SETQ %CE (CAR %E)))
	       (PRINC %%LP)
	       (%SPRINT %CE NIL)
	       (SETQ %%BR NIL)]
	      [(AND [LITATOM %CE] [SETQ %%T (GET %CE @PRINTMACRO)])
	       (COND [(STRINGP %%T)
		      (PRINC %%T)
		      (COND [(NULL (CDR %E)) (RETURN NIL)]
			    [(ATOM (SETQ %E (CADR %E))) (RETURN (PRIN1 %E))]
			    [T (GO START)])]
		     [(EQ %%T @BRACKETS) (PRINC %%LP) (PRIN1 %CE) (SETQ %%BR T)]
		     [T (RETURN (%%T %E))])]
	      [T (PRINC %%LP) (PRIN1 %CE) (SETQ %%BR NIL)])
	(COND [(ATOM (SETQ %E (CDR %E))) (PP-LSEG %E %C %C %%BR)]
	      [(MINUSP (SETQ %%T (%PPSIZE %CE (*DIF %%LL %C) T)))
	       (PP-LSEG %E %C %C %%BR)]
	      [(NOT (MINUSP (%PPSIZE %E (SETQ %%CC (CHRCT)) NIL)))
	       (PP-LSEG %E NIL NIL %%BR)]
	      [(AND [ATOM %CE]
		    [PROG (%E1)
			  (SETQ %E1 %E)
			A (COND [(CONSP (CAR %E1)) (RETURN NIL)]
				[(ATOM (SETQ %E1 (CDR %E1))) (RETURN T)]
				[T (GO A)])])
	       (PP-LSEG %E NIL (ADD1 (%CURRCOL)) %%BR)]
	      [(OR [*GREAT (SETQ %%T (DIFFERENCE %%LL %C %%T)) 14Q]
		   [CONSP %CE]
		   [AND [*GREAT %%T 1Q] [*GREAT (*TIMES 6Q (%DEPTH %E)) %%CC]])
	       (PP-LSEG %E %C %C %%BR)]
	      [T (PRINC @/ ) (PP-LSEG %E (SETQ %CE (%CURRCOL)) %CE %%BR)])
	(AND [ZEROP (CHRCT)] [TAB %C])
	(PRINC %BR)))
EXPR)
 
(DEFPROP %DEPTH
 (LAMBDA (%S)
  				       (* Returns the maximum nesting depth of
					  the list structure %S)
  (PROG (%N)
	(SETQ %N 1Q)
   LOOP	(AND [CONSP (CAR %S)] [SETQ %N (*MAX %N (ADD1 (%DEPTH (CAR %S))))])
	(COND [(CONSP (SETQ %S (CDR %S))) (GO LOOP)] [T (RETURN %N)])))
EXPR)
 
(DEFPROP PP-LSEG
 (LAMBDA (%L %C1 %C2 %BR)
  				       (* Prints the list-segment %L; %C1 gives
					  column to print lists in; %C2 gives
					  column to print atoms in <if %C2 is
					  NIL atoms are automatically indented>;
					  if %C1 is NIL the elements are printed
					  as a block <%C2 then gives the column
					  to resume printing if an element won't
					  fit on the line>; %BR is the bracket
					  flag to pass to %SPRINT)
  (PROG NIL
   LOOP	(COND [(ATOM %L) (GO DONE)]
	      [(NULL %C1)
	       (COND [(AND %C2 [MINUSP (%PPSIZE (CAR %L) (SUB1 (CHRCT)) T)])
		      (TAB %C2)]
		     [T (PRINC @/ )])
	       (COND [(ATOM (CAR %L)) (PRIN1 (CAR %L))]
		     [T (%SPRINT (CAR %L) %BR)])]
	      [(ATOM (CAR %L))
	       (TAB (OR %C2 [*MAX 2Q (SUB1 (*DIF %C1 (FLATSIZE (CAR %L))))]))
	       (PRIN1 (CAR %L))
	       (PRINC @/ )]
	      [T (TAB %C1) (%SPRINT (CAR %L) %BR)])
	(SETQ %L (CDR %L))
	(GO LOOP)
   DONE	(COND [%L (AND [*LESS (CHRCT) (*PLUS (FLATSIZE %L) 3Q)]
		       [TAB (OR %C1 %C2)])
		  (PRINC @" . ")
		  (PRIN1 %L)])))
EXPR)
 
(DEFPROP %PPSIZE
 (LAMBDA (%E %N %F)
  				       (* Checks to see if %E can be SPRINTed in
					  %N spaces; Returns negative number if
					  it can't; Returns number of spaces
					  left over if it can; %F is T if %E is
					  a real expression <a check is then
					  made for a printmacro function - they
					  are assumed not to fit>; If %F is NIL
					  %E is a segment <no top-level check
					  for printmacro>)
  (PROG NIL
  START	(COND [(ATOM %E) (RETURN (*DIF %N (FLATSIZE %E)))]
	      [(AND %F [LITATOM (CAR %E)] [SETQ %F (GET (CAR %E) @PRINTMACRO)])
	       (COND [(STRINGP %F)
		      (SETQ %N (*DIF %N (FLATSIZEC %F)))
		      (COND [(CDR %E) (SETQ %E (CADR %E)) (GO START)]
			    [T (RETURN %N)])]
		     [(NEQ %F @BRACKETS) (RETURN -1Q)])])
	(SETQ %N (SUB1 (*DIF %N (LENGTH %E))))
   LOOP	(COND [(MINUSP %N) (RETURN %N)] [T (SETQ %N (%PPSIZE (CAR %E) %N T))])
	(COND [(CONSP (SETQ %E (CDR %E))) (GO LOOP)]
	      [(NULL %E) (RETURN %N)]
	      [T (RETURN (DIFFERENCE %N (FLATSIZE %E) 3Q))])))
EXPR)
 
(DEFPROP PP-BLOCK
 (LAMBDA (%L %C)
  				       (* Prints the list %L as a block; resumes
					  printing in column %C when an element
					  of %L won't fit on the line)
  (COND [(ATOM %L) (PRIN1 %L)]
	[T (PRINC @/()
	   (SPRINT (CAR %L) (%CURRCOL))
	   (PP-LSEG (CDR %L) NIL %C NIL)
	   (AND [ZEROP (CHRCT)] [TAB %C])
	   (PRINC @/))]))
EXPR)
 
(DEFPROP PP-FORMAT
 (LAMBDA (%L %N %F)
  				       (* Formats the list %L with the first
					  %N+1 elements <the function name and
					  %N arguments> printed as a block; %F
					  specifies how the rest of the list
					  <the body> will be printed: if %F=NIL
					  <standard format> all elements will be
					  printed under the first argument; if
					  %F=LABELS all non-atomic expressions
					  will be printed under the first
					  argument with atoms placed to the left
					  <as labels>; if %F=MISER all elements
					  will be printed under the function
					  name)
  (PROG (%C1 %C2 %RP)
	(SETQ %RP %%RP)
	(PRINC %%LP)
	(SETQ %C1 (%CURRCOL))
	(PRIN1 (CAR %L))
	(SETQ %C2 (ADD1 (%CURRCOL)))
	(PP-LSEG (SETQ %N (LDIFF (CDR %L) (SETQ %L (NTH (CDDR %L) %N))))
		 NIL
		 (ADD1 %C2)
		 NIL)
	(PP-LSEG %L
		 (COND [(EQ %F @MISER) %C1] [T %C2])
		 (COND [(NULL %F) %C2] [(EQ %F @MISER) %C1])
		 NIL)
	(AND [ZEROP (CHRCT)] [TAB %C1])
	(PRINC %RP)
	(AND %L [FREELIST (PROG1 %N (SETQ %N NIL))])))
EXPR)
 
(DEFPROP * %* PRINTMACRO)
 
(DEFPROP %*
 (LAMBDA (%L)
  				       (* This is the comment printer)
  (COND [(EQ (CADR %L) @E) (EVAL (CADDR %L))])
  (COND [(OR [OUTCH] COMMENTFLG)
	 (TAB COMMENTCOL)
	 (PP-BLOCK %L (*PLUS COMMENTCOL 3Q))]
	[T (PRINC @"(* ...)")]))
EXPR)
 
(DEFPROP LAMBDA PP-LAMBDA PRINTMACRO)
 
(DEFPROP PP-LAMBDA
 (LAMBDA (%L)
  (PP-FORMAT %L 1Q @MISER))
EXPR)
 
(DEFPROP PROG PP-PROG PRINTMACRO)
 
(DEFPROP PP-PROG
 (LAMBDA (%L)
  (PP-FORMAT %L 1Q @LABELS))
EXPR)
 
(DEFPROP QUOTE "@" PRINTMACRO)
 
(DEFPROP COND BRACKETS PRINTMACRO)
 
(DEFPROP SELECTQ BRACKETS PRINTMACRO)
 
(DEFPROP CATCH BRACKETS PRINTMACRO)
 
(DEFPROP AND BRACKETS PRINTMACRO)
 
(DEFPROP OR BRACKETS PRINTMACRO)
 
(DEFPROP PRETTYFLG (NIL . T) VALUE)
 
(DEFPROP COMMENTCOL (NIL . 50Q) VALUE)
 
(DEFPROP COMMENTFLG (NIL) VALUE)
 
(DEFPROP PRETTYPROPS
 (NIL SPECIAL EXPR FEXPR MACRO VALUE PRINTMACRO (READMACRO . PP-RMACS))
VALUE)
 
(PROGN 				       (* In case someone gets cute and calls
					  %SPRINT or PP-FORMAT directly instead
					  of going thru SPRINT)
       (SETQ %%LL (LINELENGTH NIL))
       (SETQ %%LP @/()
       (SETQ %%RP @/)))
 
(PROGN 				       (* Set up names for GRINers)
       (SETQ %%T (GETL @PP @(FEXPR FSUBR)))
       (PUTPROP @GRINDEF (CADR %%T) (CAR %%T))
       (SETQ %%T (GETL @PPL @(FEXPR FSUBR)))
       (PUTPROP @GRINL (CADR %%T) (CAR %%T))
       (REMPROP @GRINPROPS @VALUE)
       (PUTPROP @GRINPROPS (GET @PRETTYPROPS @VALUE) @VALUE)
       @(GRINDEF GRINL GRINPROPS))
 
(DEFPROP PPFNS
 (PPFNS (DECLARE (SPECIAL PRETTYPROPS PRETTYFLG COMMENTCOL COMMENTFLG %%LL %%BR
			  %%CC %%T %%LP %%RP)
		 (NOCALL %SPRINT)
		 (DM * (%L) NIL))
	(PUTPROP @* (GET @NILL @FSUBR) @FSUBR)
	%CURRCOL
	PPL
	PPL*
	PP
	PP*
	PP-RMACS
	SPRINT
	%SPRINT
	%DEPTH
	PP-LSEG
	%PPSIZE
	PP-BLOCK
	PP-FORMAT
	*
	%*
	(DEFPROP LAMBDA PP-LAMBDA PRINTMACRO)
	PP-LAMBDA
	(DEFPROP PROG PP-PROG PRINTMACRO)
	PP-PROG
	(DEFPROP QUOTE "@" PRINTMACRO)
	(DEFPROP COND BRACKETS PRINTMACRO)
	(DEFPROP SELECTQ BRACKETS PRINTMACRO)
	(DEFPROP CATCH BRACKETS PRINTMACRO)
	(DEFPROP AND BRACKETS PRINTMACRO)
	(DEFPROP OR BRACKETS PRINTMACRO)
	PRETTYFLG
	COMMENTCOL
	COMMENTFLG
	PRETTYPROPS
	(PROGN 			       (* In case someone gets cute and calls
					  %SPRINT or PP-FORMAT directly instead
					  of going thru SPRINT)
	       (SETQ %%LL (LINELENGTH NIL))
	       (SETQ %%LP @/()
	       (SETQ %%RP @/)))
	(PROGN 			       (* Set up names for GRINers)
	       (SETQ %%T (GETL @PP @(FEXPR FSUBR)))
	       (PUTPROP @GRINDEF (CADR %%T) (CAR %%T))
	       (SETQ %%T (GETL @PPL @(FEXPR FSUBR)))
	       (PUTPROP @GRINL (CADR %%T) (CAR %%T))
	       (REMPROP @GRINPROPS @VALUE)
	       (PUTPROP @GRINPROPS (GET @PRETTYPROPS @VALUE) @VALUE)
	       @(GRINDEF GRINL GRINPROPS))
	PPFNS)
VALUE)

.